Acorn User: China

home *** CD-ROM | disk | FTP | other *** search

/ Acorn User: China / Acorn User China CD-ROM (UK) (Disc B) / Acorn User China CD-ROM (UK) (Disc B).bin / STUTTGART / LANG / HUGS1 / !Hugs_prelude < prev next >

Wrap

Text File | 1995-02-14 | 62.2 KB | 1,692 lines

----------------------------------------------------------------------------- -- ___ ___ ___ ___ __________ __________ -- -- / / / / / / / / / _______/ / _______/ Version 1.0 -- -- / /___/ / / / / / / / _____ / /______ -- -- / ____ / / / / / / / /_ / /______ / Copyright -- -- / / / / / /___/ / / /___/ / _______/ / Mark P Jones -- -- /__/ /__/ /_________/ /_________/ /_________/ 1994, 1995 -- -- -- -- The Haskell User's Gofer System. Derived from Gofer 2.30b. -- -- -- -- This is the Hugs Standard Prelude, based very closely on the Standard -- -- Prelude for Haskell 1.2. -- -- -- -- Hugs is subject to conditions of use and distribution; see the file -- -- "NOTICE" included with the main distribution for further details. -- -- -- -- WARNING: This file is an integral part of the Hugs source code. -- -- Changes to the definitions in this file without corresponding -- -- modifications in other parts of the program may cause the interpreter -- -- to fail unexpectedly. Under normal circumstances, you should not -- -- attempt to modify this file in any way! If you want to use a system -- -- where the prelude file can be changed, try Gofer instead. -- -- -- ----------------------------------------------------------------------------- -- Standard value bindings {Prelude} ---------------------------------------- infixr 9 . infixl 9 !!, !, // infixr 8 ^, ^^, ** -- Fixities for the following operators are taken from the -- prelude listing in Appendix A of the Haskell report. -- Note that there are some discrepancies w.r.t. Section 5.7. infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, % infix 6 :+ infixl 6 +, - infix 5 \\ infixr 5 :, ++ infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem` infixr 3 && infixr 2 || infix 1 := infixr 0 $ -- Binary functions --------------------------------------------------------- nullBin :: Bin nullBin = noBinTypeInHugs isNullBin :: Bin -> Bool isNullBin = noBinTypeInHugs appendBin :: Bin -> Bin -> Bin appendBin = noBinTypeInHugs noBinTypeInHugs = error "There is no Bin type in Hugs" -- Boolean functions -------------------------------------------------------- (&&), (||) :: Bool -> Bool -> Bool False && x = False True && x = x False || x = x True || x = True not :: Bool -> Bool not True = False not False = True otherwise :: Bool otherwise = True -- Character functions ------------------------------------------------------ minChar, maxChar :: Char minChar = '\0' maxChar = '\255' primitive ord "primCharToInt" :: Char -> Int primitive chr "primIntToChar" :: Int -> Char isAscii, isControl, isPrint, isSpace :: Char -> Bool isUpper, isLower, isAlpha, isDigit, isAlphanum :: Char -> Bool isAscii c = ord c < 128 isControl c = c < ' ' || c == '\DEL' isPrint c = c >= ' ' && c <= '~' isSpace c = c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\f' || c == '\v' isUpper c = c >= 'A' && c <= 'Z' isLower c = c >= 'a' && c <= 'z' isAlpha c = isUpper c || isLower c isDigit c = c >= '0' && c <= '9' isAlphanum c = isAlpha c || isDigit c toUpper, toLower :: Char -> Char toUpper c | isLower c = chr (ord c - ord 'a' + ord 'A') | otherwise = c toLower c | isUpper c = chr (ord c - ord 'A' + ord 'a') | otherwise = c -- Numeric functions -------------------------------------------------------- primitive minInt "primMinInt", maxInt "primMaxInt" :: Int subtract :: Num a => a -> a -> a subtract = flip (-) gcd :: Integral a => a -> a -> a gcd 0 0 = error "gcd{Prelude}: gcd 0 0 is undefined" gcd x y = gcd' (abs x) (abs y) where gcd' x 0 = x gcd' x y = gcd' y (x `rem` y) lcm :: (Integral a) => a -> a -> a lcm _ 0 = 0 lcm 0 _ = 0 lcm x y = abs ((x `quot` gcd x y) * y) (^) :: (Num a, Integral b) => a -> b -> a x ^ 0 = 1 x ^ (n+1) = f x n x where f _ 0 y = y f x n y = g x n where g x n | even n = g (x*x) (n`quot`2) | otherwise = f x (n-1) (x*y) _ ^ _ = error "(^){Prelude}: negative exponent" (^^) :: (Fractional a, Integral b) => a -> b -> a x ^^ n = if n >= 0 then x ^ n else recip (x^(-n)) fromIntegral :: (Integral a, Num b) => a -> b fromIntegral = fromInteger . toInteger fromRealFrac :: (RealFrac a, Fractional b) => a -> b fromRealFrac = fromRational . toRational atan2 :: (RealFloat a) => a -> a -> a atan2 y x = case (signum y, signum x) of ( 0, 1) -> 0 ( 1, 0) -> pi/2 ( 0,-1) -> pi (-1, 0) -> -pi/2 ( _, 1) -> atan (y/x) ( _,-1) -> atan (y/x) + pi ( 0, 0) -> error "atan2{Prelude}: atan2 of origin" -- Some standard functions -------------------------------------------------- -- component projections for pairs: fst :: (a,b) -> a fst (x,_) = x snd :: (a,b) -> b snd (_,y) = y -- identity function id :: a -> a id x = x -- constant function const :: a -> b -> a const k _ = k -- function composition (.) :: (b -> c) -> (a -> b) -> (a -> c) (f . g) x = f (g x) -- flip f takes its (first) two arguuments in the reverse order of f. flip :: (a -> b -> c) -> b -> a -> c flip f x y = f y x -- right associative infix application operator (useful in continuation- -- passing style) ($) :: (a -> b) -> a -> b -- pronounced as `apply' elsewhere f $ x = f x -- until p f yields the result of applying f until p holds until :: (a -> Bool) -> (a -> a) -> a -> a until p f x | p x = x | otherwise = until p f (f x) -- asTypeOf is a type restricted version of const. It is usually used -- as an infix operator, and its typing forces its first argument -- (which is usually overloaded) to have the same type as the second. asTypeOf :: a -> a -> a asTypeOf = const -- error is applied to a string, returns any type, and is everywhere -- undefined. Operationally, the intent is that its application -- terminates execution of the program and displays the argument -- string in some appropriate way. primitive error "primError" :: String -> a -- strict is not defined in the Haskell prelude, but Hugs doesn't have a -- strictness analyzer and it's occasionally useful to be able to exercise -- some added degree over the order of evaluation. primitive strict "primStrict" :: (a -> b) -> a -> b -- Standard types, classes and instances {PreludeCore} ---------------------- -- Equality and Ordered classes --------------------------------------------- class Eq a where (==), (/=) :: a -> a -> Bool x /= y = not (x==y) -- ordcmp is a new variation on an old idea; ordcmp x y r returns -- True if x>y, False if x<y and r otherwise. The conventional ordering -- operators are defined in terms of ordcmp, but a default definition of -- ordcmp is also provided just in case. It is an error (but not detected -- by the compiler) for the programmer to omit definitions both for <= -- and for ordcmp. It will also be assumed that the ordering is consistent -- with the equality. -- e.g. ordcmp (x:xs) (y:ys) = ordcmp x y . ordcmp xs ys -- -- Unlike Haskell 1.2, we now assume that orderings are total. class (Eq a) => Ord a where ordcmp :: a -> a -> Bool -> Bool (<), (<=), (>=), (>) :: a -> a -> Bool max, min :: a -> a -> a -- ordcmp x y r = ... define in terms of <= and == only and be -- careful not to eval r until it is needed ... ordcmp x y r = if x<=y then (x==y && r) else True x > y = ordcmp x y False x >= y = ordcmp x y True x < y = ordcmp y x False x <= y = ordcmp y x True max x y | x >= y = x | otherwise = y min x y | x <= y = x | otherwise = y -- Numeric classes ---------------------------------------------------------- class (Eq a, Text a) => Num a where (+), (-), (*) :: a -> a -> a negate :: a -> a abs, signum :: a -> a fromInteger :: Integer -> a fromInt :: Int -> a x - y = x + negate y class (Num a, Enum a) => Real a where toRational :: a -> Rational class (Real a, Ix a) => Integral a where quot, rem, div, mod :: a -> a -> a quotRem, divMod :: a -> a -> (a,a) even, odd :: a -> Bool toInteger :: a -> Integer toInt :: a -> Int n `quot` d = q where (q,r) = quotRem n d n `rem` d = r where (q,r) = quotRem n d n `div` d = q where (q,r) = divMod n d n `mod` d = r where (q,r) = divMod n d divMod n d = if signum r == - signum d then (q-1, r+d) else qr where qr@(q,r) = quotRem n d even n = n `rem` 2 == 0 odd = not . even class (Num a) => Fractional a where (/) :: a -> a -> a recip :: a -> a fromRational :: Rational -> a fromDouble :: Double -> a recip x = 1 / x class (Fractional a) => Floating a where pi :: a exp, log, sqrt :: a -> a (**), logBase :: a -> a -> a sin, cos, tan :: a -> a asin, acos, atan :: a -> a sinh, cosh, tanh :: a -> a asinh, acosh, atanh :: a -> a x ** y = exp (log x * y) logBase x y = log y / log x sqrt x = x ** 0.5 tan x = sin x / cos x sinh x = (exp x - exp (-x)) / 2 cosh x = (exp x + exp (-x)) / 2 tanh x = sinh x / cosh x asinh x = log (x + sqrt (x*x + 1)) acosh x = log (x + sqrt (x*x - 1)) atanh x = (log (1 + x) - log (1 - x)) / 2 class (Real a, Fractional a) => RealFrac a where properFraction :: (Integral b) => a -> (b,a) truncate, round :: (Integral b) => a -> b ceiling, floor :: (Integral b) => a -> b truncate x = m where (m,_) = properFraction x round x = let (n,r) = properFraction x m = if r < 0 then n - 1 else n + 1 in case signum (abs r - 0.5) of -1 -> n 0 -> if even n then n else m 1 -> m ceiling x = if r > 0 then n + 1 else n where (n,r) = properFraction x floor x = if r < 0 then n - 1 else n where (n,r) = properFraction x class (RealFrac a, Floating a) => RealFloat a where floatRadix :: a -> Integer floatDigits :: a -> Int floatRange :: a -> (Int,Int) decodeFloat :: a -> (Integer,Int) encodeFloat :: Integer -> Int -> a exponent :: a -> Int significand :: a -> a scaleFloat :: Int -> a -> a exponent x = if m==0 then 0 else n + floatDigits x where (m,n) = decodeFloat x significand x = encodeFloat m (- floatDigits x) where (m,_) = decodeFloat x scaleFloat k x = encodeFloat m (n+k) where (m,n) = decodeFloat x -- Index and Enumeration classes -------------------------------------------- class (Ord a) => Ix a where range :: (a,a) -> [a] index :: (a,a) -> a -> Int inRange :: (a,a) -> a -> Bool class (Ord a) => Enum a where enumFrom :: a -> [a] -- [n..] enumFromThen :: a -> a -> [a] -- [n,m..] enumFromTo :: a -> a -> [a] -- [n..m] enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m] enumFromTo n m = takeWhile (m>=) (enumFrom n) enumFromThenTo n n' m = takeWhile ((if n'>=n then (>=) else (<=)) m) (enumFromThen n n') -- Text class --------------------------------------------------------------- type ReadS a = String -> [(a,String)] type ShowS = String -> String class Text a where readsPrec :: Int -> ReadS a showsPrec :: Int -> a -> ShowS readList :: ReadS [a] showList :: [a] -> ShowS readList = readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s ]) where readl s = [([],t) | ("]",t) <- lex s] ++ [(x:xs,u) | (x,t) <- reads s, (xs,u) <- readl' t] readl' s = [([],t) | ("]",t) <- lex s] ++ [(x:xs,v) | (",",t) <- lex s, (x,u) <- reads t, (xs,v) <- readl' u] showList [] = showString "[]" showList (x:xs) = showChar '[' . shows x . showl xs where showl [] = showChar ']' showl (x:xs) = showChar ',' . shows x . showl xs -- Binary class ------------------------------------------------------------- -- Although Hugs does not provide any operations on the binary datatype, Bin, -- we include the definition of the Binary class here for compatibility with -- Haskell ... all of this may go in later versions of Haskell and Hugs. class Binary a where readBin :: Bin -> (a,Bin) showBin :: a -> Bin -> Bin readBin = noBinTypeInHugs showBin = noBinTypeInHugs -- Trivial type ------------------------------------------------------------- -- data () = () deriving (Eq, Ord, Ix, Enum, Text, Binary) instance Eq () where () == () = True instance Ord () where ordcmp () () s = s instance Ix () where range ((),()) = [()] index ((),()) () = 0 inRange ((),()) () = True instance Enum () where enumFrom () = [()] enumFromThen () () = [()] instance Text () where readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r, (")",t) <- lex s ]) showsPrec p () = showString "()" instance Binary () -- Binary type -------------------------------------------------------------- instance Text Bin where readsPrec p s = error "readsPrec{PreludeText}: Cannot read Bin" showsPrec d b = showString "<<Bin>>>" -- Boolean type ------------------------------------------------------------- data Bool = False | True deriving (Eq, Ord, Ix, Enum, Text, Binary) -- Character type ----------------------------------------------------------- primitive primEqChar "primEqChar", primLeChar "primLeChar" :: Char -> Char -> Bool instance Eq Char where (==) = primEqChar -- c == d = ord c == ord d instance Ord Char where (<=) = primLeChar -- c <= d = ord c <= ord d instance Ix Char where range (c,c') = [c..c'] index b@(c,c') ci | inRange b ci = ord ci - ord c | otherwise = error "index{PreludeCore}: Index out of range" inRange (c,c') ci = ord c <= i && i <= ord c' where i = ord ci instance Enum Char where enumFrom c = map chr [ord c .. ord maxChar] enumFromThen c c' = map chr [ord c, ord c' .. ord lastChar] where lastChar = if c' < c then minChar else maxChar instance Text Char where readsPrec p = readParen False (\r -> [(c,t) | ('\'':s,t) <- lex r, (c,_) <- readLitChar s]) showsPrec p '\'' = showString "'\\''" showsPrec p c = showChar '\'' . showLitChar c . showChar '\'' readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r, (l,_) <- readl s ]) where readl ('"':s) = [("",s)] readl ('\\':'&':s) = readl s readl s = [(c:cs,u) | (c ,t) <- readLitChar s, (cs,u) <- readl t ] showList cs = showChar '"' . showl cs where showl "" = showChar '"' showl ('"':cs) = showString "\\\"" . showl cs showl (c:cs) = showChar c . showl cs -- Haskell has showLitChar c . showl cs type String = [Char] -- Standard Integral types -------------------------------------------------- primitive primEqInt "primEqInt" :: Int -> Int -> Bool primitive primCmpInt "primCmpInt" :: Int -> Int -> Bool -> Bool primitive primEqInteger "primEqInteger" :: Integer -> Integer -> Bool primitive primCmpInteger "primCmpInteger":: Integer -> Integer -> Bool -> Bool instance Eq Int where (==) = primEqInt instance Eq Integer where (==) = primEqInteger instance Ord Int where ordcmp = primCmpInt instance Ord Integer where ordcmp = primCmpInteger primitive primPlusInt "primPlusInt", primMinusInt "primMinusInt", primMulInt "primMulInt" :: Int -> Int -> Int primitive primNegInt "primNegInt" :: Int -> Int primitive primIntegerToInt "primIntegerToInt" :: Integer -> Int instance Num Int where (+) = primPlusInt (-) = primMinusInt negate = primNegInt (*) = primMulInt abs = absReal signum = signumReal fromInteger = primIntegerToInt fromInt x = x primitive primPlusInteger "primPlusInteger", primMinusInteger "primMinusInteger", primMulInteger "primMulInteger" :: Integer -> Integer -> Integer primitive primNegInteger "primNegInteger" :: Integer -> Integer primitive primIntToInteger "primIntToInteger" :: Int -> Integer instance Num Integer where (+) = primPlusInteger (-) = primMinusInteger negate = primNegInteger (*) = primMulInteger abs = absReal signum = signumReal fromInteger x = x fromInt = primIntToInteger absReal x | x >= 0 = x | otherwise = -x signumReal x | x == 0 = 0 | x > 0 = 1 | otherwise = -1 instance Real Int where toRational x = toInteger x % 1 instance Real Integer where toRational x = x % 1 primitive primDivInt "primDivInt", primQuotInt "primQuotInt", primRemInt "primRemInt", primModInt "primModInt" :: Int -> Int -> Int instance Integral Int where div = primDivInt quot = primQuotInt rem = primRemInt mod = primModInt quotRem n d = (n `quot` d, n `rem` d) toInteger = primIntToInteger toInt x = x primitive primQrmInteger "primQrmInteger" :: Integer -> Integer -> (Integer,Integer) primitive primEvenInteger "primEvenInteger" :: Integer -> Bool instance Integral Integer where quotRem = primQrmInteger even = primEvenInteger toInteger x = x toInt = primIntegerToInt instance Ix Int where range (m,n) = [m..n] index b@(m,n) i | inRange b i = i - m | otherwise = error "index{PreludeCore}: Index out of range" inRange (m,n) i = m <= i && i <= n instance Ix Integer where range (m,n) = [m..n] index b@(m,n) i | inRange b i = fromInteger (i - m) | otherwise = error "index{PreludeCore}: Index out of range" inRange (m,n) i = m <= i && i <= n instance Enum Int where enumFrom = numericEnumFrom enumFromThen = numericEnumFromThen instance Enum Integer where enumFrom = numericEnumFrom enumFromThen = numericEnumFromThen numericEnumFrom :: Real a => a -> [a] numericEnumFromThen :: Real a => a -> a -> [a] numericEnumFrom = iterate (1+) numericEnumFromThen n m = iterate ((m-n)+) n primitive primShowsInt "primShowsInt" :: Int -> Int -> ShowS instance Text Int where readsPrec p = readSigned readDec showsPrec = primShowsInt primitive primShowsInteger "primShowsInteger" :: Int -> Integer -> ShowS instance Text Integer where readsPrec p = readSigned readDec showsPrec = primShowsInteger -- Standard Floating types -------------------------------------------------- primitive primEqFloat "primEqFloat", primLeFloat "primLeFloat" :: Float -> Float -> Bool primitive primEqDouble "primEqDouble", primLeDouble "primLeDouble" :: Double -> Double -> Bool instance Eq Float where (==) = primEqFloat instance Eq Double where (==) = primEqDouble instance Ord Float where (<=) = primLeFloat instance Ord Double where (<=) = primLeDouble primitive primPlusFloat "primPlusFloat", primMinusFloat "primMinusFloat", primMulFloat "primMulFloat" :: Float -> Float -> Float primitive primNegFloat "primNegFloat" :: Float -> Float primitive primIntToFloat "primIntToFloat" :: Int -> Float primitive primIntegerToFloat "primIntegerToFloat" :: Integer -> Float instance Num Float where (+) = primPlusFloat (-) = primMinusFloat negate = primNegFloat (*) = primMulFloat abs = absReal signum = signumReal fromInteger = primIntegerToFloat fromInt = primIntToFloat primitive primPlusDouble "primPlusDouble", primMinusDouble "primMinusDouble", primMulDouble "primMulDouble" :: Double -> Double -> Double primitive primNegDouble "primNegDouble" :: Double -> Double primitive primIntToDouble "primIntToDouble" :: Int -> Double primitive primIntegerToDouble "primIntegerToDouble" :: Integer -> Double instance Num Double where (+) = primPlusDouble (-) = primMinusDouble negate = primNegDouble (*) = primMulDouble abs = absReal signum = signumReal fromInteger = primIntegerToDouble fromInt = primIntToDouble instance Real Float where toRational = realFloatToRational instance Real Double where toRational = realFloatToRational realFloatToRational x = (m%1)*(b%1)^^n where (m,n) = decodeFloat x b = floatRadix x primitive primDivFloat "primDivFloat" :: Float -> Float -> Float primitive primDoubleToFloat "primDoubleToFloat" :: Double -> Float instance Fractional Float where (/) = primDivFloat fromRational = rationalToRealFloat fromDouble = primDoubleToFloat primitive primDivDouble "primDivDouble" :: Double -> Double -> Double instance Fractional Double where (/) = primDivDouble fromRational = rationalToRealFloat fromDouble x = x rationalToRealFloat x = x' where x' = f e f e = if e' == e then y else f e' where y = encodeFloat (round (x * (1%b)^^e)) e (_,e') = decodeFloat y (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x' / fromInteger (denominator x)) b = floatRadix x' primitive primPiFloat "primPiFloat" :: Float primitive primSinFloat "primSinFloat", primAsinFloat "primAsinFloat", primCosFloat "primCosFloat", primAcosFloat "primAcosFloat", primTanFloat "primTanFloat", primAtanFloat "primAtanFloat", primLogFloat "primLogFloat", primExpFloat "primExpFloat", primSqrtFloat "primSqrtFloat" :: Float -> Float instance Floating Float where pi = primPiFloat exp = primExpFloat log = primLogFloat sqrt = primSqrtFloat sin = primSinFloat cos = primCosFloat tan = primTanFloat asin = primAsinFloat acos = primAcosFloat atan = primAtanFloat primitive primPiDouble "primPiDouble" :: Double primitive primSinDouble "primSinDouble", primAsinDouble "primAsinDouble", primCosDouble "primCosDouble", primAcosDouble "primAcosDouble", primTanDouble "primTanDouble", primAtanDouble "primAtanDouble", primLogDouble "primLogDouble", primExpDouble "primExpDouble", primSqrtDouble "primSqrtDouble" :: Double -> Double instance Floating Double where pi = primPiDouble exp = primExpDouble log = primLogDouble sqrt = primSqrtDouble sin = primSinDouble cos = primCosDouble tan = primTanDouble asin = primAsinDouble acos = primAcosDouble atan = primAtanDouble instance RealFrac Float where properFraction = floatProperFraction instance RealFrac Double where properFraction = floatProperFraction floatProperFraction x | n >= 0 = (fromInteger m * fromInteger b ^ n, 0) | otherwise = (fromInteger w, encodeFloat r n) where (m,n) = decodeFloat x b = floatRadix x (w,r) = quotRem m (b^(-n)) primitive primFloatRadix "primFloatRadix" :: Float -> Integer primitive primFloatDigits "primFloatDigits" :: Float -> Int primitive primFloatRange "primFloatRange" :: Float -> (Int,Int) primitive primFloatEncode "primFloatEncode" :: Integer -> Int -> Float primitive primFloatDecode "primFloatDecode" :: Float -> (Integer, Int) instance RealFloat Float where floatRadix = primFloatRadix floatDigits = primFloatDigits floatRange = primFloatRange encodeFloat = primFloatEncode decodeFloat = primFloatDecode primitive primDoubleRadix "primDoubleRadix" :: Double -> Integer primitive primDoubleDigits "primDoubleDigits" :: Double -> Int primitive primDoubleRange "primDoubleRange" :: Double -> (Int,Int) primitive primDoubleEncode "primDoubleEncode" :: Integer -> Int -> Double primitive primDoubleDecode "primDoubleDecode" :: Double -> (Integer, Int) instance RealFloat Double where floatRadix = primDoubleRadix floatDigits = primDoubleDigits floatRange = primDoubleRange encodeFloat = primDoubleEncode decodeFloat = primDoubleDecode instance Enum Float where enumFrom = numericEnumFrom enumFromThen = numericEnumFromThen instance Enum Double where enumFrom = numericEnumFrom enumFromThen = numericEnumFromThen primitive primShowsFloat "primShowsFloat" :: Int -> Float -> ShowS instance Text Float where readsPrec p = readSigned readFloat showsPrec = primShowsFloat primitive primShowsDouble "primShowsDouble" :: Int -> Double -> ShowS instance Text Double where readsPrec p = readSigned readFloat showsPrec = primShowsDouble -- Lists -------------------------------------------------------------------- instance Eq a => Eq [a] where [] == [] = True (x:xs) == (y:ys) = x==y && xs==ys _ == _ = False instance Ord a => Ord [a] where [] <= _ = True (_:_) <= [] = False (x:xs) <= (y:ys) = x<y || (x==y && xs<=ys) instance Text a => Text [a] where readsPrec p = readList showsPrec p = showList -- Tuples ------------------------------------------------------------------- -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Text, Binary) -- etc.. -- Functions ---------------------------------------------------------------- instance Text (a -> b) where readsPrec p s = error "readsPrec{PreludeCore}: Cannot read functions" showsPrec p f = showString "<<function>>" -- Standard functions on rational numbers {PreludeRatio} -------------------- data Integral a => Ratio a = a :% a deriving (Eq, Binary) type Rational = Ratio Integer (%) :: Integral a => a -> a -> Ratio a x % y = reduce (x * signum y) (abs y) reduce :: Integral a => a -> a -> Ratio a reduce x y | y== 0 = error "(%){PreludeRatio}: zero denominator" | otherwise = (x `quot` d) :% (y `quot` d) where d = gcd x y numerator, denominator :: Integral a => Ratio a -> a numerator (x :% y) = x denominator (x :% y) = y instance Integral a => Ord (Ratio a) where ordcmp (x:%y) (x':%y') = ordcmp (x*y') (x'*y) instance Integral a => Num (Ratio a) where (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y') (x:%y) * (x':%y') = reduce (x*x') (y*y') negate (x :% y) = negate x :% y abs (x :% y) = abs x :% y signum (x :% y) = signum x :% 1 fromInteger x = fromInteger x :% 1 fromInt x = fromInt x :% 1 instance Integral a => Real (Ratio a) where toRational (x:%y) = toInteger x :% toInteger y instance Integral a => Fractional (Ratio a) where (x:%y) / (x':%y') = (x*y') % (y*x') recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x fromRational (x:%y) = fromInteger x :% fromInteger y fromDouble x | n>=0 = (fromInteger m * fromInteger b ^ n) % 1 | otherwise = fromInteger m % (fromInteger b ^ (-n)) where (m,n) = decodeFloat x b = floatRadix x instance Integral a => RealFrac (Ratio a) where properFraction (x:%y) = (fromIntegral q, r:%y) where (q,r) = quotRem x y instance Integral a => Enum (Ratio a) where enumFrom = numericEnumFrom enumFromThen = numericEnumFromThen instance Integral a => Text (Ratio a) where readsPrec p = readParen (p > 7) (\r -> [(x%y,u) | (x,s) <- reads r, ("%",t) <- lex s, (y,u) <- reads t ]) showsPrec p (x:%y) = showParen (p > 7) (shows x . showString " % " . shows y) approxRational :: RealFrac a => a -> a -> Rational approxRational x eps = simplest (x-eps) (x+eps) where simplest x y | y < x = simplest y x | x == y = xr | x > 0 = simplest' n d n' d' | y < 0 = - simplest' (-n') d' (-n) d | otherwise = 0 :% 1 where xr@(n:%d) = toRational x (n':%d') = toRational y simplest' n d n' d' -- assumes 0 < n%d < n'%d' | r == 0 = q :% 1 | q /= q' = (q+1) :% 1 | otherwise = (q*n''+d'') :% n'' where (q,r) = quotRem n d (q',r') = quotRem n' d' (n'':%d'') = simplest' d' r' d r -- Complex numbers {PreludeComplex} ----------------------------------------- data RealFloat a => Complex a = a :+ a deriving (Eq, Binary, Text) instance RealFloat a => Num (Complex a) where (x:+y) + (x':+y') = (x+x') :+ (y+y') (x:+y) - (x':+y') = (x-x') :+ (y-y') (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x') negate (x:+y) = negate x :+ negate y abs z = magnitude z :+ 0 signum 0 = 0 signum z@(x:+y) = x/r :+ y/r where r = magnitude z fromInteger n = fromInteger n :+ 0 fromInt n = fromInt n :+ 0 instance RealFloat a => Fractional (Complex a) where (x:+y) / (x':+y') = (x*x''+y*y'')/d :+ (y*x''-x*y'')/d where x'' = scaleFloat k x' y'' = scaleFloat k y' k = - max (exponent x') (exponent y') d = x'*x'' + y'*y'' fromRational a = fromRational a :+ 0 fromDouble a = fromDouble a :+ 0 instance RealFloat a => Floating (Complex a) where pi = pi :+ 0 exp (x:+y) = expx * cos y :+ expx * sin y where expx = exp x log z = log (magnitude z) :+ phase z sqrt 0 = 0 sqrt z@(x:+y) = u :+ (if y < 0 then -v else v) where (u,v) = if x<0 then (v',u') else (u',v') v' = abs y / (u'*2) u' = sqrt ((magnitude z + abs x) / 2) sin (x:+y) = sin x * cosh y :+ cos x * sinh y cos (x:+y) = cos x * cosh y :+ (- sin x * sinh y) tan (x:+y) = (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy)) where sinx = sin x cosx = cos x sinhy = sinh y coshy = cosh y sinh (x:+y) = sinh x * cos y :+ cosh x * sin y cosh (x:+y) = cosh x * cos y :+ sinh x * sin y tanh (x:+y) = (sinhx*cosy:+coshx*siny)/(coshx*cosy:+sinhx*siny) where siny = sin y cosy = cos y sinhx = sinh x coshx = cosh x asin z@(x:+y) = y' :+ (-x') where (x':+y') = log ((-y:+x) + sqrt (1 - z*z)) acos z@(x:+y) = y'':+(-x'') where (x'':+y'') = log (z + ((-y'):+x')) (x' :+ y') = sqrt (1 - z*z) atan z@(x:+y) = y' :+ (-x') where (x':+y') = log (((1-y):+x) / sqrt (1+z*z)) asinh z = log (z + sqrt (1+z*z)) acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1))) atanh z = log ((1+z) / sqrt (1 - z*z)) realPart, imagPart :: RealFloat a => Complex a -> a realPart (x :+ y) = x imagPart (x :+ y) = y conjugate :: RealFloat a => Complex a -> Complex a conjugate (x :+ y) = x :+ (-y) mkPolar :: RealFloat a => a -> a -> Complex a mkPolar r theta = r * cos theta :+ r * sin theta cis :: RealFloat a => a -> Complex a cis theta = cos theta :+ sin theta polar :: RealFloat a => Complex a -> (a, a) polar z = (magnitude z, phase z) magnitude, phase :: RealFloat a => Complex a -> a magnitude (x :+ y) = scaleFloat k (sqrt ((scaleFloat mk x)^2 + (scaleFloat mk y)^2)) where k = max (exponent x) (exponent y) mk = -k phase (x :+ y) = atan2 y x -- Standard list functions {PreludeList} ------------------------------------ head :: [a] -> a head (x:_) = x last :: [a] -> a last [x] = x last (_:xs) = last xs tail :: [a] -> [a] tail (_:xs) = xs init :: [a] -> [a] init [x] = [] init (x:xs) = x : init xs -- null provides a simple and efficient way of determining whether a given -- list is empty, without using (==) and hence avoiding an Eq a constraint. null :: [a] -> Bool null [] = True null (_:_) = False (++) :: [a] -> [a] -> [a] -- append lists. Associative with [] ++ ys = ys -- left and right identity []. (x:xs) ++ ys = x:(xs++ys) -- (\\) is used to remove the first occurrence of each element in the second -- list from the first list. It is a kind of inverse of (++) in the sense -- that (xs ++ ys) \\ xs = ys for any finite list xs of proper values xs. (\\) :: Eq a => [a] -> [a] -> [a] (\\) = foldl del where [] `del` _ = [] (x:xs) `del` y | x == y = xs | otherwise = x : xs `del` y -- length returns the length of a finite list as an Int; it is an instance -- of the more general genericLength, the result type of which may be -- any kind of number genericLength :: Num a => [b] -> a genericLength = foldl' (\n _ -> n + 1) 0 length :: [a] -> Int length = genericLength -- List index (subscript) operator, 0-origin (!!) :: (Integral a) => [b] -> a -> b (x:_) !! 0 = x (_:xs) !! (n+1) = xs !! n -- map f xs applies the function f to each element of the list xs returning -- the corresponding list of results. filter p xs returns the sublist of xs -- containing those elements which satisfy the predicate p. map :: (a -> b) -> [a] -> [b] map f [] = [] map f (x:xs) = f x : map f xs filter :: (a -> Bool) -> [a] -> [a] filter p = foldr (\x xs -> if p x then x:xs else xs) [] -- partition takes a predicate and a list and returns a pair of lists: -- those elements of the argument list that do and do not satisfy the -- predicate, respectively. partition :: (a -> Bool) -> [a] -> ([a],[a]) partition p = foldr select ([],[]) where select x (ts,fs) | p x = (x:ts,fs) | otherwise = (ts,x:fs) -- Fold primitives: The foldl and scanl functions, variants foldl1 and -- scanl1 for non-empty lists, and strict variants foldl' scanl' describe -- common patterns of recursion over lists. Informally: -- -- foldl f a [x1, x2, ..., xn] = f (...(f (f a x1) x2)...) xn -- = (...((a `f` x1) `f` x2)...) `f` xn -- etc... -- -- The functions foldr, scanr and variants foldr1, scanr1 are duals of these -- functions: -- e.g. foldr f a xs = foldl (flip f) a (reverse xs) for finite lists xs. foldl :: (a -> b -> a) -> a -> [b] -> a foldl f z [] = z foldl f z (x:xs) = foldl f (f z x) xs foldl' :: (a -> b -> a) -> a -> [b] -> a foldl' f a [] = a foldl' f a (x:xs) = strict (foldl' f) (f a x) xs foldl1 :: (a -> a -> a) -> [a] -> a foldl1 f (x:xs) = foldl f x xs scanl :: (a -> b -> a) -> a -> [b] -> [a] scanl f q xs = q : (case xs of [] -> [] x:xs -> scanl f (f q x) xs) scanl1 :: (a -> a -> a) -> [a] -> [a] scanl1 f (x:xs) = scanl f x xs foldr :: (a -> b -> b) -> b -> [a] -> b foldr f z [] = z foldr f z (x:xs) = f x (foldr f z xs) foldr1 :: (a -> a -> a) -> [a] -> a foldr1 f [x] = x foldr1 f (x:xs) = f x (foldr1 f xs) scanr :: (a -> b -> b) -> b -> [a] -> [b] scanr f q0 [] = [q0] scanr f q0 (x:xs) = f x q : qs where qs@(q:_) = scanr f q0 xs scanr1 :: (a -> a -> a) -> [a] -> [a] scanr1 f [x] = [x] scanr1 f (x:xs) = f x q : qs where qs@(q:_) = scanr1 f xs iterate :: (a -> a) -> a -> [a] -- generate the infinite list iterate f x = x : iterate f (f x) -- [x, f x, f (f x), ... repeat :: a -> [a] -- generate the infinite list repeat x = xs where xs = x:xs -- [x, x, x, x, ... cycle :: [a] -> [a] -- generate the infinite list cycle xs = xs' where xs'=xs++xs'-- xs ++ xs ++ xs ++ ... -- List breaking functions: -- -- take n xs returns the first n elements of xs -- drop n xs returns the remaining elements of xs -- splitAt n xs = (take n xs, drop n xs) -- -- takeWhile p xs returns the longest initial segment of xs whose -- elements satisfy p -- dropWhile p xs returns the remaining portion of the list -- span p xs = (takeWhile p xs, dropWhile p xs) -- -- takeUntil p xs returns the list of elements upto and including the -- first element of xs which satisfies p take :: Integral a => a -> [b] -> [b] take 0 _ = [] take _ [] = [] take (n+1) (x:xs) = x : take n xs drop :: Integral a => a -> [b] -> [b] drop 0 xs = xs drop _ [] = [] drop (n+1) (_:xs) = drop n xs splitAt :: Integral a => a -> [b] -> ([b], [b]) splitAt 0 xs = ([],xs) splitAt _ [] = ([],[]) splitAt (n+1) (x:xs) = (x:xs',xs'') where (xs',xs'') = splitAt n xs takeWhile :: (a -> Bool) -> [a] -> [a] takeWhile p [] = [] takeWhile p (x:xs) | p x = x : takeWhile p xs | otherwise = [] dropWhile :: (a -> Bool) -> [a] -> [a] dropWhile p [] = [] dropWhile p xs@(x:xs') | p x = dropWhile p xs' | otherwise = xs span, break :: (a -> Bool) -> [a] -> ([a],[a]) span p [] = ([],[]) span p xs@(x:xs') | p x = let (ys,zs) = span p xs' in (x:ys,zs) | otherwise = ([],xs) break p = span (not . p) -- Text processing: -- lines s returns the list of lines in the string s. -- words s returns the list of words in the string s. -- unlines ls joins the list of lines ls into a single string -- with lines separated by newline characters. -- unwords ws joins the list of words ws into a single string -- with words separated by spaces. lines :: String -> [String] lines "" = [] lines s = l : (if null s' then [] else lines (tail s')) where (l, s') = break ('\n'==) s words :: String -> [String] words s = case dropWhile isSpace s of "" -> [] s' -> w : words s'' where (w,s'') = break isSpace s' unlines :: [String] -> String unlines = concat . map (\l -> l ++ "\n") unwords :: [String] -> String unwords [] = [] unwords ws = foldr1 (\w s -> w ++ ' ':s) ws nub :: Eq a => [a] -> [a] -- remove duplicates from list nub [] = [] nub (x:xs) = x : nub (filter (x/=) xs) reverse :: [a] -> [a] -- reverse elements of list reverse = foldl (flip (:)) [] and, or :: [Bool] -> Bool and = foldr (&&) True -- returns conjunction of boolean list or = foldr (||) False -- returns disjunction of boolean list any, all :: (a -> Bool) -> [a] -> Bool any p = or . map p all p = and . map p elem, notElem :: Eq a => a -> [a] -> Bool elem = any . (==) -- test for membership in list notElem = all . (/=) -- test for non-membership sum, product :: Num a => [a] -> a sum = foldl' (+) 0 product = foldl' (*) 1 sums, products :: Num a => [a] -> [a] sums = scanl (+) 0 products = scanl (*) 1 maximum, minimum :: Ord a => [a] -> a maximum = foldl1 max -- max element in non-empty list minimum = foldl1 min -- min element in non-empty list concat :: [[a]] -> [a] -- concatenate list of lists concat = foldr (++) [] transpose :: [[a]] -> [[a]] -- transpose list of lists transpose = foldr (\xs xss -> zipWith (:) xs (xss ++ repeat [])) [] -- zip and zipWith families of functions: zip :: [a] -> [b] -> [(a,b)] zip = zipWith (\a b -> (a,b)) zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] zip3 = zipWith3 (\a b c -> (a,b,c)) zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)] zip4 = zipWith4 (\a b c d -> (a,b,c,d)) zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)] zip5 = zipWith5 (\a b c d e -> (a,b,c,d,e)) zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a,b,c,d,e,f)] zip6 = zipWith6 (\a b c d e f -> (a,b,c,d,e,f)) zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [(a,b,c,d,e,f,g)] zip7 = zipWith7 (\a b c d e f g -> (a,b,c,d,e,f,g)) zipWith :: (a->b->c) -> [a]->[b]->[c] zipWith z (a:as) (b:bs) = z a b : zipWith z as bs zipWith _ _ _ = [] zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d] zipWith3 z (a:as) (b:bs) (c:cs) = z a b c : zipWith3 z as bs cs zipWith3 _ _ _ _ = [] zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] zipWith4 z (a:as) (b:bs) (c:cs) (d:ds) = z a b c d : zipWith4 z as bs cs ds zipWith4 _ _ _ _ _ = [] zipWith5 :: (a->b->c->d->e->f) -> [a]->[b]->[c]->[d]->[e]->[f] zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) = z a b c d e : zipWith5 z as bs cs ds es zipWith5 _ _ _ _ _ _ = [] zipWith6 :: (a->b->c->d->e->f->g) -> [a]->[b]->[c]->[d]->[e]->[f]->[g] zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) = z a b c d e f : zipWith6 z as bs cs ds es fs zipWith6 _ _ _ _ _ _ _ = [] zipWith7 :: (a->b->c->d->e->f->g->h) -> [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h] zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) = z a b c d e f g : zipWith7 z as bs cs ds es fs gs zipWith7 _ _ _ _ _ _ _ _ = [] unzip :: [(a,b)] -> ([a],[b]) unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], []) unzip3 :: [(a,b,c)] -> ([a],[b],[c]) unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs)) ([],[],[]) unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d]) unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) -> (a:as,b:bs,c:cs,d:ds)) ([],[],[],[]) unzip5 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e]) unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) -> (a:as,b:bs,c:cs,d:ds,e:es)) ([],[],[],[],[]) unzip6 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f]) unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) -> (a:as,b:bs,c:cs,d:ds,e:es,f:fs)) ([],[],[],[],[],[]) unzip7 :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g]) unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) -> (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs)) ([],[],[],[],[],[],[]) -- Standard array functions {PreludeArray} ---------------------------------- data Assoc a b = a := b deriving (Eq, Ord, Ix, Text, Binary) array :: Ix a => (a,a) -> [Assoc a b] -> Array a b listArray :: Ix a => (a,a) -> [b] -> Array a b (!) :: Ix a => Array a b -> a -> b bounds :: Ix a => Array a b -> (a,a) indices :: Ix a => Array a b -> [a] elems :: Ix a => Array a b -> [b] assocs :: Ix a => Array a b -> [Assoc a b] accumArray :: Ix a => (b -> c -> b) -> b -> (a,a) -> [Assoc a c] -> Array a b (//) :: Ix a => Array a b -> [Assoc a b] -> Array a b accum :: Ix a => (b -> c -> b) -> Array a b -> [Assoc a c] -> Array a b amap :: Ix a => (b -> c) -> Array a b -> Array a c ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c primitive primArray "primArray" :: (a -> Int) -> (a,a) -> [Assoc a b] -> Array a b primitive primUpdate "primUpdate" :: (a -> Int) -> Array a b -> [Assoc a b] -> Array a b primitive primAccum "primAccum" :: (a -> Int) -> (b -> c -> b) -> Array a b -> [Assoc a c] -> Array a b primitive primAccumArray "primAccumArray" :: (a -> Int) -> (b -> c -> b) -> b -> (a,a) -> [Assoc a c] -> Array a b primitive primBounds "primBounds" :: Array a b -> (a,a) primitive primElems "primElems" :: Array a b -> [b] primitive primSubscript "primSubscript" :: (a -> Int) -> Array a b -> a -> b primitive primAmap "primAmap" :: (b -> c) -> Array a b -> Array a c array bounds assocs = primArray (index bounds) bounds assocs listArray b vs = array b (zipWith (:=) (range b) vs) (!) a = primSubscript (index (bounds a)) a bounds = primBounds indices = range . bounds elems = primElems assocs a = zipWith (:=) (indices a) (elems a) accumArray f z b = primAccumArray (index b) f z b a // as = primUpdate (index (bounds a)) a as accum f a = primAccum (index (bounds a)) f a amap = primAmap ixmap b f a = array b [ i := (a ! f i) | i <- range b ] instance (Ix a, Eq b) => Eq (Array a b) where a == a' = assocs a == assocs a' instance (Ix a, Ord b) => Ord (Array a b) where a <= a' = assocs a <= assocs a' instance (Ix a, Text a, Text b) => Text (Array a b) where showsPrec p a = showParen (p > 9) ( showString "array " . shows (bounds a) . showChar ' ' . shows (assocs a)) instance (Ix a, Binary a, Binary b) => Binary (Array a b) rangeSize :: (Ix a) => (a,a) -> Int rangeSize r@(l,u) = index r u + 1 -- PreludeText ---------------------------------------------------------------- reads :: Text a => ReadS a reads = readsPrec 0 shows :: Text a => a -> ShowS shows = showsPrec 0 read :: Text a => String -> a read s = case [x | (x,t) <- reads s, ("","") <- lex t] of [x] -> x [] -> error "read{PreludeText}: no parse" _ -> error "read{PreludeText}: ambiguous parse" show :: Text a => a -> String show x = shows x "" showChar :: Char -> ShowS showChar = (:) showString :: String -> ShowS showString = (++) showParen :: Bool -> ShowS -> ShowS showParen b p = if b then showChar '(' . p . showChar ')' else p readParen :: Bool -> ReadS a -> ReadS a readParen b g = if b then mandatory else optional where optional r = g r ++ mandatory r mandatory r = [(x,u) | ("(",s) <- lex r, (x,t) <- optional s, (")",u) <- lex t ] lex :: ReadS String lex "" = [("","")] lex (c:s) | isSpace c = lex (dropWhile isSpace s) lex ('-':'-':s) = case dropWhile (/= '\n') s of '\n':t -> lex t _ -> [] -- unterminated end-of-line -- comment lex ('{':'-':s) = lexNest lex s where lexNest f ('-':'}':s) = f s lexNest f ('{':'-':s) = lexNest (lexNest f) s lexNest f (c:s) = lexNest f s lexNest _ "" = [] -- unterminated -- nested comment lex ('<':'-':s) = [("<-",s)] lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s, ch /= "'" ] lex ('"':s) = [('"':str, t) | (str,t) <- lexString s] where lexString ('"':s) = [("\"",s)] lexString s = [(ch++str, u) | (ch,t) <- lexStrItem s, (str,u) <- lexString t ] lexStrItem ('\\':'&':s) = [("\\&",s)] lexStrItem ('\\':c:s) | isSpace c = [("\\&",t) | '\\':t <- [dropWhile isSpace s]] lexStrItem s = lexLitChar s lex (c:s) | isSingle c = [([c],s)] | isSym1 c = [(c:sym,t) | (sym,t) <- [span isSym s]] | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]] | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s], (fe,t) <- lexFracExp s ] | otherwise = [] -- bad character where isSingle c = c `elem` ",;()[]{}_" isSym1 c = c `elem` "-~" || isSym c isSym c = c `elem` "!@#$%&*+./<=>?\\^|:" isIdChar c = isAlphanum c || c `elem` "_'" lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s, (e,u) <- lexExp t ] lexFracExp s = [("",s)] lexExp (e:s) | e `elem` "eE" = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-", (ds,u) <- lexDigits t] ++ [(e:ds,t) | (ds,t) <- lexDigits s] lexExp s = [("",s)] lexDigits :: ReadS String lexDigits = nonnull isDigit nonnull :: (Char -> Bool) -> ReadS String nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]] lexLitChar :: ReadS String lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s] where lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)] lexEsc s@(d:_) | isDigit d = lexDigits s lexEsc ('o':s) = [('o':os, t) | (os,t) <- nonnull isOctDigit s] lexEsc ('x':s) = [('x':xs, t) | (xs,t) <- nonnull isHexDigit s] lexEsc s@(c:_) | isUpper c = case [(mne,s') | mne <- "DEL" : elems asciiTab, ([],s') <- [lexmatch mne s] ] of (pr:_) -> [pr] [] -> [] lexEsc _ = [] lexLitChar (c:s) = [([c],s)] lexLitChar "" = [] isOctDigit c = c >= '0' && c <= '7' isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f' lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a]) lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys lexmatch xs ys = (xs,ys) asciiTab = listArray ('\NUL', ' ') ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US", "SP"] readLitChar :: ReadS Char readLitChar ('\\':s) = readEsc s where readEsc ('a':s) = [('\a',s)] readEsc ('b':s) = [('\b',s)] readEsc ('f':s) = [('\f',s)] readEsc ('n':s) = [('\n',s)] readEsc ('r':s) = [('\r',s)] readEsc ('t':s) = [('\t',s)] readEsc ('v':s) = [('\v',s)] readEsc ('\\':s) = [('\\',s)] readEsc ('"':s) = [('"',s)] readEsc ('\'':s) = [('\'',s)] readEsc ('^':c:s) | c >= '@' && c <= '_' = [(chr (ord c - ord '@'), s)] readEsc s@(d:_) | isDigit d = [(chr n, t) | (n,t) <- readDec s] readEsc ('o':s) = [(chr n, t) | (n,t) <- readOct s] readEsc ('x':s) = [(chr n, t) | (n,t) <- readHex s] readEsc s@(c:_) | isUpper c = let table = ('\DEL':= "DEL") : assocs asciiTab in case [(c,s') | (c := mne) <- table, ([],s') <- [lexmatch mne s]] of (pr:_) -> [pr] [] -> [] readEsc _ = [] readLitChar (c:s) = [(c,s)] showLitChar :: Char -> ShowS showLitChar c | c > '\DEL' = showChar '\\' . protectEsc isDigit (shows (ord c)) showLitChar '\DEL' = showString "\\DEL" showLitChar '\\' = showString "\\\\" showLitChar c | c >= ' ' = showChar c showLitChar '\a' = showString "\\a" showLitChar '\b' = showString "\\b" showLitChar '\f' = showString "\\f" showLitChar '\n' = showString "\\n" showLitChar '\r' = showString "\\r" showLitChar '\t' = showString "\\t" showLitChar '\v' = showString "\\v" showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO") showLitChar c = showString ('\\' : asciiTab!c) protectEsc p f = f . cont where cont s@(c:_) | p c = "\\&" ++ s cont s = s readDec, readOct, readHex :: Integral a => ReadS a readDec = readInt 10 isDigit (\d -> ord d - ord '0') readOct = readInt 8 isOctDigit (\d -> ord d - ord '0') readHex = readInt 16 isHexDigit hex where hex d = ord d - (if isDigit d then ord '0' else ord (if isUpper d then 'A' else 'a') - 10) readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a readInt radix isDig digToInt s = [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r) | (ds,r) <- nonnull isDig s ] showInt :: Integral a => a -> ShowS showInt n r = let (n',d) = quotRem n 10 r' = chr (ord '0' + fromIntegral d) : r in if n' == 0 then r' else showInt n' r' readSigned:: Real a => ReadS a -> ReadS a readSigned readPos = readParen False read' where read' r = read'' r ++ [(-x,t) | ("-",s) <- lex r, (x,t) <- read'' s] read'' r = [(n,s) | (str,s) <- lex r, (n,"") <- readPos str] showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS showSigned showPos p x = if x < 0 then showParen (p > 6) (showChar '-' . showPos (-x)) else showPos x readFloat :: RealFloat a => ReadS a readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r, (k,t) <- readExp s] where readFix r = [(read (ds++ds'), length ds', t) | (ds,'.':s) <- lexDigits r, (ds',t) <- lexDigits s ] readExp (e:s) | e `elem` "eE" = readExp' s readExp s = [(0,s)] readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s] readExp' ('+':s) = readDec s readExp' s = readDec s showFloat :: RealFloat a => a -> ShowS showFloat x = if x==0 then showString ("0." ++ take (m-1) (repeat '0')) else if e >= m-1 || e < 0 then showSci else showFix where showFix = showString whole . showChar '.' . showString frac where (whole,frac) = splitAt (e+1) (show sig) showSci = showChar d . showChar '.' . showString frac . showChar 'e' . shows e where (d:frac) = show sig (m,sig,e) = if b == 10 then (w, s, n+w-1) else (m',sig',e') m' = ceiling (fromIntegral w * log (fromInteger b) / log 10 :: Double) + 1 (sig',e') = if sig1 >= 10^m' then (round (t/10), e1+1) else if sig1 < 10^(m'-1) then (round (t*10), e1-1) else (sig1, e1) sig1 = round t t = s%1 * (b%1)^^n * 10^^(m'-e1-1) e1 = floor (logBase 10 x) (s,n) = decodeFloat x b = floatRadix x w = floatDigits x -- I/O functions and definitions {PreludeIO} ---------------------------------- stdin = "stdin" stdout = "stdout" stderr = "stderr" stdecho = "stdecho" data Request = -- file system requests: ReadFile String | WriteFile String String | AppendFile String String -- channel system requests: | ReadChan String | AppendChan String String -- environment requests: | Echo Bool | GetArgs | GetProgName | GetEnv String data Response = Success | Str String | Failure IOError | StrList [String] data IOError = WriteError String | ReadError String | SearchError String | FormatError String | OtherError String type Dialogue = [Response] -> [Request] type SuccCont = Dialogue type StrCont = String -> Dialogue type StrListCont = [String] -> Dialogue type FailCont = IOError -> Dialogue done :: Dialogue readFile :: String -> FailCont -> StrCont -> Dialogue writeFile :: String -> String -> FailCont -> SuccCont -> Dialogue appendFile :: String -> String -> FailCont -> SuccCont -> Dialogue readChan :: String -> FailCont -> StrCont -> Dialogue appendChan :: String -> String -> FailCont -> SuccCont -> Dialogue echo :: Bool -> FailCont -> SuccCont -> Dialogue getArgs :: FailCont -> StrListCont -> Dialogue getProgName :: FailCont -> StrCont -> Dialogue getEnv :: String -> FailCont -> StrCont -> Dialogue done resps = [] readFile name fail succ resps = (ReadFile name) : strDispatch fail succ resps writeFile name contents fail succ resps = (WriteFile name contents) : succDispatch fail succ resps appendFile name contents fail succ resps = (AppendFile name contents) : succDispatch fail succ resps readChan name fail succ resps = (ReadChan name) : strDispatch fail succ resps appendChan name contents fail succ resps = (AppendChan name contents) : succDispatch fail succ resps echo bool fail succ resps = (Echo bool) : succDispatch fail succ resps getArgs fail succ resps = GetArgs : strListDispatch fail succ resps getProgName fail succ resps = GetProgName : strDispatch fail succ resps getEnv name fail succ resps = (GetEnv name) : strDispatch fail succ resps strDispatch fail succ (resp:resps) = case resp of Str val -> succ val resps Failure msg -> fail msg resps succDispatch fail succ (resp:resps) = case resp of Success -> succ resps Failure msg -> fail msg resps strListDispatch fail succ (resp:resps) = case resp of StrList val -> succ val resps Failure msg -> fail msg resps abort :: FailCont abort err = done exit :: FailCont exit err = appendChan stderr msg abort done where msg = case err of ReadError s -> s WriteError s -> s SearchError s -> s FormatError s -> s OtherError s -> s print :: Text a => a -> Dialogue print x = appendChan stdout (show x) exit done prints :: Text a => a -> String -> Dialogue prints x s = appendChan stdout (shows x s) exit done interact :: (String -> String) -> Dialogue interact f = readChan stdin exit (\x -> appendChan stdout (f x) exit done) -- Hooks for primitives: ----------------------------------------------------- -- Do not mess with these! data Maybe a = Just a | Nothing primPmInt :: Num a => Int -> a -> Bool primPmInt n x = fromInt n == x primPmInteger :: Num a => Integer -> a -> Bool primPmInteger n x = fromInteger n == x primPmFlt :: Fractional a => Double -> a -> Bool primPmFlt n x = fromDouble n == x primPmNpk :: Integral a => Int -> a -> Maybe a primPmNpk n x = if n'<=x then Just (x-n') else Nothing where n' = fromInt n primPmSub :: Integral a => Int -> a -> a primPmSub n x = x - fromInt n -- End of Hugs standard prelude ----------------------------------------------